Fritz: All Fritz/All Fritz.zip/All Fritz/FILES/PROGSCAL/ANIMATE.LZH/SHOWMOVI.PAS

Pascal/Delphi Source File | 1984-09-14 | 6KB | 233 lines

program ShowAMovie;
type
  ParamString = string[10];
  ScreenLoc = record
                character : char;
                attribute : byte;
              end;
  DefinedLoc  = record
                data : ScreenLoc;
                c,r  : byte;
              end;
  OneLine   = array[1..80] of ScreenLoc;
  Screen    = array[1..25] of OneLine;
  ScreenSet = ^node;
  node      = record
                AScreen : Screen;
                next    : ScreenSet;
              end;
  DiffFil  = file of DefinedLoc;
var
  parameter_len            : byte absolute CSeg:$0080;
  parameterLine            : string[40] absolute CSeg:$0080;
  parameters               : array[1..4] of ParamString;
  ScreenItself             : Screen absolute $B000:$0000;
  ColorScreen              : Screen absolute $B800:$0000;
  LastScreen               : Screen;
  Screens, Pointer         : ScreenSet;
  ScreenNum, times,
  col, row, N, P           : byte;
  DiffFile                 : DiffFil;
  filename                 : string[14];
  exists, OKAY, color      : boolean;
  EndLoc                   : DefinedLoc;
  ScreenSeg                : integer;

{≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡}
procedure GetParameters;
begin
  Parameters[1] := 'nofile';
  Parameters[2] := 'r';
  Parameters[3] := '50';
  Parameters[4] := '5';
  for N := 1 to 4 do
    begin
      P := pos('/',parameterLine);
      if P <> 0 then
        begin
          parameters[N] := copy(parameterLine,1,P-1);
          if parameters[N][1] = ' ' then delete(Parameters[N],1,1);
          delete(parameterLine,1,P);
        end;
    end;
end;
{≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡}
function number(P : ParamString):integer;
var
  code, temp : integer;
begin
  val(P, temp, code);
  if code = 0 then number := temp
  else
    begin
      number := 0;
      OKAY   := false;
    end;
end;
{≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡}
procedure AttemptReset(var ThisFile : DiffFil);
begin
  {$I-}
  reset(ThisFile);
  {$I+}
end;
{≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡}
function different(var C,D:screenLoc):boolean;
begin
  different := (C.character <> D.character) or
               (C.attribute <> D.attribute);
end;
{≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡}
procedure AddScreen(ScreenToAdd:Screen);
var
  temp : ScreenSet;
begin
  new(temp);
  temp^.AScreen := ScreenToAdd;
  temp^.next    := Screens;
  Screens       := temp;
  ScreenNum     := ScreenNum + 1;
end;
{≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡}
procedure ReadScreenFile;
var
  diff : DefinedLoc;
begin
  OKAY := true;
    for row := 1 to 25 do
      for col := 1 to 80 do
        with LastScreen[row][col] do
          begin
            character := ' ';
            attribute := 15;
          end;
    ClrScr;
    filename := Parameters[1] + '.scn';
    Assign(DiffFile,filename);
    WriteLn;
    AttemptReset(DiffFile);
    if FileSize(DiffFile) > 0 then
      begin
        ScreenNum := 0;
        GotoXY(20,10);
        TextColor(white + blink);
        Write('LOADING MOVIE  . . .');
        TextColor(white);
        While not EOF(DiffFile) do
          begin
            read(DiffFile,diff);
              if different(diff.data,EndLoc.data) then
                  LastScreen[diff.r][diff.c] := diff.data
              else
                  AddScreen(LastScreen);
          end;  {while}
      end   {if}
    else
      begin
        gotoXY(20,10);
        WriteLn('Not found');
        OKAY := false;
      end;
    close(DiffFile);
end;
{≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡}
procedure DoPlay(list:ScreenSet;wait:integer);
begin
  if list <> nil then
    begin
      DoPlay(list^.next,wait);
      ScreenItself := list^.AScreen;
      ColorScreen  := list^.AScreen;
      delay(wait);
    end;
end;
{≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡}
procedure PlayScreens;
var
  wait : integer;
begin
  wait := number(Parameters[3]);
  if OKAY then
    begin
      Pointer := Screens;
      DoPlay(Pointer,wait);
    end
  else
    begin
      GotoXY(20,10);
      Write('Invalid parameter #3');
    end;
end;
{≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡}
procedure CycleScreens;
var
  wait : integer;
begin
  wait := number(Parameters[3]);
  if OKAY then
    repeat
      Pointer := Screens;
      DoPlay(Pointer,wait);
    until keypressed
  else
    begin
      GotoXY(20,10);
      Write('Invalid parameter #3');
    end;
end;
{≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡}
procedure initialize;
begin
  if (Mem[0000:1040] and 48) <> 48 then
    begin
      ScreenSeg := $B800;
      color     := true;
    end
  else
    begin
      ScreenSeg := $B000;
      color     := false;
    end;
  ScreenNum := 0;
  Screens := nil;
  with EndLoc do
    begin
      data.character := chr(0);
      data.attribute := 0;
      r := 0; c := 0;
    end;
end;
{≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡}
begin
  initialize;
  GetParameters;
  ReadScreenFile;
  GotoXY(1,1);
  if OKAY then
    begin
      case UpCase(Parameters[2][1]) of
        'C': CycleScreens;
        'O': begin
               PlayScreens;
               repeat until keypressed;
             end;
        'R': begin
               times := number(parameters[4]);
               if OKAY then
                 begin
                   for N := 1 to times do PlayScreens;
                   repeat until keypressed;
                 end
               else
                 begin
                   GotoXY(20,10);
                   Write('Invalid parameter #4');
                 end;
             end;
      else
        GotoXY(20,10);
        Write('Invalid parameter #2');
      end; {case}
  end;  {if OKAY}
  ClrScr;
end.